home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d13
/
oct90.arc
/
FOLD.LSP
< prev
next >
Wrap
Text File
|
1990-11-01
|
8KB
|
372 lines
; Fold.Lsp [Article Figure 2] (c)1990, Phil Kreiker
; COPYRIGHT 1990 BY
; LOOKING GLASS MICROPRODUCTS
;
(Setq
version "1.0"
<180 Pi
)
;---------------------------------------
; Load-time chewing gum
;---------------------------------------
(Princ "\n")
(Setq bcount 0)
(Defun bump ()
(Setq bcount (1+ bcount))
(Princ
(Strcat
"\rFold version "
version
" -- Copyright 1990
by Looking Glass Microproducts : "
(ItoA bcount)
)
)
)
;---------------------------------------
; Item from association list
;---------------------------------------
(bump)
(Defun item (n e)
(CDR (Assoc n e))
)
;---------------------------------------
; Error Handler
;---------------------------------------
(bump)
(Defun bend-error (s)
(If (/= S "Function cancelled")
(Princ s)
)
(Command)
(Command)
(Command ".UNDO" "e")
(If undoit
(Progn
(Princ "\nUndoing...")
(Command ".U")
)
)
(moder)
)
;---------------------------------------
; System variable save
;---------------------------------------
(bump)
(Defun modes (a)
(Setq MLST Nil)
(Repeat
(Length a)
(Setq
MLST (Append
MLST
(List
(List
(CAR a)
(GetVar (CAR a))
)
)
)
)
(Setq a (CDR a))
)
)
;---------------------------------------
; System variable restore
;---------------------------------------
(bump)
(Defun moder ()
(Repeat
(Length MLST)
(Setvar
(CAAR MLST) (CADAR MLST)
)
(Setq MLST (CDR MLST))
)
(Setq *Error* olderror)
(Princ)
)
;---------------------------------------
; System variable set
;---------------------------------------
(bump)
(Defun setvars (mlst)
(Repeat
(Length MLST)
(Setvar
(CAAR MLST) (CADAR MLST)
)
(Setq MLST (CDR MLST))
)
)
;---------------------------------------
; Radians to Degrees
;---------------------------------------
(bump)
(Defun rtod (x)
(/ (* 180.0 x) <180)
)
;---------------------------------------
; Mark vertices with points
;---------------------------------------
(bump)
(Defun markverts (pname / ent ename ss1)
(Command ".ucs" "w")
(Setq
ent (EntGet pname)
Ename pname
ss1 (SsAdd)
)
(While (=
"VERTEX"
(item
0
(Setq
Ename (EntNext Ename)
ent (EntGet Ename)
)
)
)
(Redraw ename 3)
(Command
".point"
(item 10 ent)
)
(SsAdd (EntLast) ss1)
)
(Redraw pname)
(Command ".ucs" "p")
ss1
)
;---------------------------------------
; Bold vertices to points
;---------------------------------------
(bump)
(Defun bendverts (pname ss1
/ ent ename i pntname pntent)
(Setq
ent (EntGet pname)
Ename pname
i 0
)
(While (=
"VERTEX"
(item
0
(Setq
Ename (EntNext Ename)
ent (EntGet Ename)
)
)
)
(Redraw ename 3)
(Setq
pntname (SsName ss1 i)
i (1+ i)
pntent (EntGet pntname)
)
(EntMod
(Subst
(Assoc 10 pntent)
(Assoc 10 ent)
ent
)
)
)
; Force a regen of the mesh such that
; undo and redo will regen.
; Entupd won't make it
(Command
".move" meshname ""
'(0 0 0) ""
)
)
;---------------------------------------
; Returns the selection set of all
; entities which are members of both
;ss1 and ss2.
;---------------------------------------
(bump)
(Defun meet (ss1 ss2 / pt1 ssa ssb)
(If (And ss1 ss2)
(Progn
(Command
".point"
(GetVar "viewctr")
)
(Setq pt1 (EntLast))
(Command
".select" pt1 ss1 "r" ss2 ""
)
(Setq ssa (SsGet "P"))
(SsDel pt1 ssa)
(Command
".select" pt1 ss1 "r" ssa ""
)
(Setq ssb (SsGet "P"))
(SsDel pt1 ssb)
(EntDel pt1)
(If (> (SsLength ssb) 0) ssb)
)
)
)
;---------------------------------------
; GET A 3D MESH OR 3D POLYLINE
;---------------------------------------
(bump)
(Defun getmesh (/ again ename ent)
(Setq again T)
(While again
(If (Setq
ename (CAR
(EntSel
"\nSelect a mesh or 3D polyline: "
)
)
)
(Progn
(Setq ent (EntGet ename))
(If (And
(= (item 0 ent)"POLYLINE")
(>= (item 70 ent) 8)
)
(Progn
(Setq again Nil) ename)
(Princ
"\nNot a mesh or 3D polyline."
)
)
)
(Setq again Nil)
)
)
)
;---------------------------------------
; GET FOLD LINE
;---------------------------------------
(Defun getbendline (/ p1 p2)
(While (= p1 p2)
(InitGet 1)
(Setq
p1 (GetPoint
"\nFirst point of fold line: "
)
)
(InitGet 1)
(Setq
p2 (GetPoint p1 "Second point: ")
)
(If (= p1 p2)
(Princ
"\nPoints must be distinct."
)
)
)
(List p1 p2)
)
;---------------------------------------
; BEND MAIN ROUTINE
;---------------------------------------
(bump)
(Defun bend (/ ss1 ss2 meshname ok
undoit bendline)
(Setq
meshname (getmesh)
ok meshname
)
(If ok
(Progn
(Setq bm (GetVar "blipmode"))
(Setvar "blipmode" 0)
(Setvar "highlight" 0)
;
(Setq
undoit T
ss1 (markverts meshname)
; place a point on each vertex
)
(Setvar "blipmode" bm)
(Prompt
"\nSelect vertices..."
)
(Setq
ss2 (meet (SsGet) ss1)
; get the vertices we wish to fold
ok ss2
)
)
)
(If ok
(Progn
(Setq bendline (getbendline))
; get the fold line
(Command
".ucs" "za"
(CAR bendline)
(CADR bendline)
)
(InitGet 1)
; get the fold angle
(Setq
ang (rtod
(GetAngle
'(0 0 0)
"\nFold angle: "
)
)
)
(Setvar "pdmode" 1)
(Command
; rotate the vertices we wish to fold
".rotate" ss2 ""
'(0 0 0) ang
)
(Command ".ucs" "p")
(bendverts meshname ss1)
; fold the mesh
)
)
(If ss1
(Command ".erase" ss1 "")
; remove the markers
)
(Setq ss1 Nil ss2 Nil)
)
;---------------------------------------
; BEND COMMAND
;---------------------------------------
(bump)
(Defun c:fold (/ olderror undoit)
(modes
'("cmdecho"
"osmode"
"flatland"
"elevation"
"thickness"
"blipmode"
"highlight"
"pdmode"
)
)
(Setq
olderror *Error*
*Error* bend-error
)
(setvars
'(("cmdecho" 0)
("osmode" 0)
("flatland" 0)
("elevation" 0.0)
("thickness" 0.0)
)
)
(Command ".undo" "group")
(bend)
(Command ".undo" "e")
(moder)
)
(c:fold)